Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/ole/ole2.frm

Text File | 1995-05-08 | 7KB | 295 lines

VERSION 2.00
Begin Form frm_main
   BorderStyle     =   1  'Fixed Single
   Caption         =   "OLE Destination Example"
   ClientHeight    =   3180
   ClientLeft      =   2025
   ClientTop       =   2295
   ClientWidth     =   3885
   Height          =   3870
   Left            =   1965
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   80.379
   ScaleMode       =   0  'User
   ScaleWidth      =   101.39
   Top             =   1665
   Width           =   4005
   Begin OLE ole_Destination
      fFFHk           =   -1  'True
      Height          =   3135
      HostName        =   "OLE Demo"
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Verb            =   -1
      Width           =   3855
   End
   Begin Menu mnuFile
      Caption         =   "&File"
      Begin Menu mnuExit
         Caption         =   "E&xit"
      End
   End
   Begin Menu mnuedit
      Caption         =   "&Edit"
      Begin Menu mnuName
         Caption         =   "None"
         Enabled         =   0   'False
         Begin Menu mnuVerbs
            Caption         =   "Verbs"
            Index           =   0
         End
      End
      Begin Menu mpaste
         Caption         =   "&Paste"
      End
      Begin Menu mplink
         Caption         =   "Paste &Link"
      End
      Begin Menu mnuPasteSpecial
         Caption         =   "Paste &Special"
      End
      Begin Menu mnuInsert
         Caption         =   "&Insert Object"
      End
      Begin Menu sep
         Caption         =   "-"
      End
      Begin Menu mdel
         Caption         =   "&Delete Object"
      End
      Begin Menu mnuSep2
         Caption         =   "-"
      End
      Begin Menu mnuUpdate
         Caption         =   "&Update"
      End
   End
End
Option Explicit

Dim aPath As String

Sub Form_Load ()
    Dim FileNum ' Declare variable.
'
'   Get startup Path of OLE2 Application
'
    aPath = app.Path
    If Right$(aPath, 1) <> "\" Then
    aPath = aPath + "\"
    End If
'
'   Setup file for OLE
'   If present read and restore OLE control
'
    FileNum = FreeFile  ' Get a valid file number.
    On Error GoTo oleErr
    Open aPath & "oleTst.OLE" For Binary As FileNum   ' Open file to be saved.
    ole_Destination.FileNumber = FileNum ' Set the OLEClient filenumber.
    ole_Destination.Action = 12  ' read the file.
    Close #FileNum  ' Close the file.
    mnuName.Caption = ole_Destination.Class

continue:
    If windowstate = 1 Then Exit Sub
    Me.ScaleMode = 1
    Me.Width = (ole_Destination.Width + 300)
    Me.Height = (ole_Destination.Height + 800)
    Me.ScaleMode = 6
    Exit Sub

oleErr:
'
'   OLETST.OLE file not found OK OLE Object set to NULL
'
    Close #FileNum  ' Close the file.
    mnuName.Caption = "No Object"
    Resume continue
End Sub

Sub Form_Unload (Cancel As Integer)
    Dim FileNum ' Declare variable.
'
'   If object is in OLE control save it to file!
'
    If ole_Destination.OLEType <> 3 Then
    FileNum = FreeFile  ' Get a valid file number.
    Open aPath & "oleTst.OLE" For Binary As FileNum   ' Open file to be saved.
    ole_Destination.FileNumber = FileNum ' Set the OLEClient filenumber.
    ole_Destination.Action = 11  ' Save the file.
    Close #FileNum  ' Close the file.
    Else
    Kill aPath & "oletst.ole"   'Erase old OLE File
    End If
'
'   Stop execution of Application
'
    End
End Sub

Sub mdel_Click ()
'
'   Delete the OLE object in the OLE Control
'
    If ole_Destination.OLEType = 3 Then
    Beep
    Else
    ole_Destination.Action = 10      'Delete Object
    '
    '   Restore original size
    '
    If windowstate = 1 Then Exit Sub
    Me.ScaleMode = 1
    Me.Width = (ole_Destination.Width + 300)
    Me.Height = (ole_Destination.Height + 800)
    Me.ScaleMode = 6
    End If
    mnuName.Caption = "No Object"
End Sub

Sub mnuedit_Click ()
    Dim Verb As Integer
'
'   Check clipboard and greyout Edit commands
'   as needed
'
    If ole_Destination.PasteOK Then
    mPaste.Enabled = True
    mpLink.Enabled = True
    mnuPasteSpecial.Enabled = True
    Else
    mPaste.Enabled = False
    mpLink.Enabled = False
    mnuPasteSpecial.Enabled = False
    End If
    If ole_Destination.OLEType = 3 Then  'None
    mDel = False
    mnuUpdate.Enabled = False
    mnuName.Enabled = False
    mnuInsert.Enabled = True
    Else
    mDel = True
    mnuUpdate.Enabled = True
    mnuName.Enabled = True
    mnuInsert.Enabled = False
    End If
'
'   OLE Object Class name
'   and cascade menu of verbs
'
'   Set Form properties now that it contains an object.
'
    On Error Resume Next
    For Verb = 1 To ole_Destination.ObjectVerbsCount - 1
    Load mnuVerbs(Verb - 1)
    If Err = 360 Then       'Object already loaded.
    Unload mnuVerbs(Verb - 1)
    Load mnuVerbs(Verb - 1)
    Err = 0
    End If
    mnuVerbs(Verb - 1).Caption = ole_Destination.ObjectVerbs(Verb - 1)
    Next Verb
End Sub

Sub mnuExit_Click ()
    Unload Me
End Sub

Sub mnuInsert_Click ()
'
'   Use Insert Object Dialog Box to build new OLE
'   Object.  User chooses OLE Application to
'   create this new object from OLE Registration
'   database (REG.DAT)
'
    On Error GoTo insertErr
    If ole_Destination.OLEType <> 3 Then
    Beep
    Exit Sub
    End If
    ole_Destination.Action = 14      'Insert Object Dialog Box
    ole_Destination.Action = 7       'OLE Activate
    mnuName.Caption = ole_Destination.Class
    Exit Sub

insertErr:
    MsgBox "OLE ERROR - Inserting Object"
    Resume 0
End Sub

Sub mnuPasteSpecial_Click ()
'
'   Show Paste Special Dialog Box
'   Allows user to choose Embed or Link type
'
    If ole_Destination.PasteOK Then
    ole_Destination.Action = 15  'Paste Special
    Else
    Beep
    End If
    mnuName.Caption = ole_Destination.Class
End Sub

Sub mnuUpdate_Click ()
'
'   Update Object by calling OLE Application
'
    ole_Destination.Action = 6   'Update Object
    mnuName.Caption = ole_Destination.Class
End Sub

Sub mnuVerbs_Click (Index As Integer)
'
'   Execute a verb to OLE Application
'
    ole_Destination.Verb = Index
    If UCase(mnuVerbs(Index).Caption) = "&EDIT" Then ole_Destination.Verb = -1    'In-Place-Edit
    ole_Destination.Action = 7   'Activate
End Sub

Sub mpaste_Click ()
'
'   Paste from Clipboard (Embedded Type)
'
    ole_Destination.OLEType = 1  ' Embedded
    If ole_Destination.PasteOK Then
    ole_Destination.Action = 5   'Paste
    Else
    Beep
    End If
    mnuName.Caption = ole_Destination.Class
End Sub

Sub mplink_Click ()
'
'   Paste from clipboard (Link Type)
'
    ole_Destination.OLEType = 0  ' Linked

    If ole_Destination.PasteOK Then
    ole_Destination.Action = 5  'Paste
    Else
    Beep
    End If
    mnuName.Caption = ole_Destination.Class
End Sub

Sub ole_Destination_Updated (Code As Integer)
'
'   Gets control when object was changed by
'       OLE Application
'
    Dim rc As Integer
    If ole_Destination.OLEType = 3 Then
    Exit Sub
    End If
    If windowstate = 1 Then Exit Sub
    Me.ScaleMode = 1
    Me.Width = (ole_Destination.Width + 300)
    Me.Height = (ole_Destination.Height + 800)
    Me.ScaleMode = 6
End Sub